home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / utils / text-props.el < prev    next >
Encoding:
Text File  |  1995-08-30  |  20.5 KB  |  485 lines
  1. ;;; text-props.el --- implements properties of characters
  2.  
  3. ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1995 Amdahl Corporation.
  5.  
  6. ;; Keywords: extensions, wp, faces
  7. ;; Author: Jamie Zawinski <jwz@lucid.com>
  8. ;; Modified: Ben Wing <wing@netcom.com> -- many of the Lisp functions below
  9. ;;           were completely broken.
  10. ;;
  11. ;; This file is part of XEmacs.
  12.  
  13. ;; XEmacs is free software; you can redistribute it and/or modify
  14. ;; it under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; XEmacs is distributed in the hope that it will be useful,
  19. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;; GNU General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with XEmacs; see the file COPYING.  If not, write to
  25. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27.  
  28. ;;; Commentary:
  29.  
  30. ;;; This is a nearly complete implementation of the FSF19 text properties API,
  31. ;;; except that this code currently only works on buffers, not strings.
  32. ;;; Please let me know if you notice any differences in behavior between
  33. ;;; this implementation and the FSF implementation.
  34. ;;;
  35. ;;; However, keep in mind that this interface has been implemented because it
  36. ;;; is useful.  Compatibility with code written for FSF19 is a secondary goal
  37. ;;; to having a clean and useful interface.
  38. ;;;
  39. ;;; The cruftier parts of the FSF API, such as the special handling of
  40. ;;; properties like `mouse-face', `front-sticky', and other properties whose
  41. ;;; value is a list of names of *other* properties set at this position, are
  42. ;;; not implemented.  The reason for this is that if you feel you need that
  43. ;;; kind of functionality, it's a good hint that you should be using extents
  44. ;;; instead of text properties.
  45. ;;;
  46. ;;; When should I use Text Properties, and when should I use Extents?
  47. ;;; ==================================================================
  48. ;;;
  49. ;;; If you are putting a `button' or `hyperlink' of some kind into a buffer,
  50. ;;; the most natural interface is one which deals with properties of regions
  51. ;;; with explicit endpoints that behave more-or-less like markers.  That is
  52. ;;; what `make-extent', `extent-at', and `extent-property' are for.
  53. ;;;
  54. ;;; If you are dealing with styles of text, where things do not have explicit
  55. ;;; endpoints (as is done in font-lock.el and shell-font.el) or if you want to
  56. ;;; partition a buffer (that is, change some attribute of a range from one
  57. ;;; value to another without disturbing the properties outside of that range)
  58. ;;; then an interface that deals with properties of characters may be most
  59. ;;; natural.  
  60. ;;;
  61. ;;; Another way of thinking of it is, do you care where the endpoints of the
  62. ;;; region are?  If you do, then you should use extents.  If it's ok for the
  63. ;;; region to become divided, and for two regions with identical properties to
  64. ;;; be merged into one region, then you might want to use text properties.
  65. ;;;
  66. ;;; Some applications want the attributes they add to be copied by the killing
  67. ;;; and yanking commands, and some do not.  This is orthogonal to whether text
  68. ;;; properties or extents are used.  Remember that text properties are
  69. ;;; implemented in terms of extents, so anything you can do with one you can
  70. ;;; do with the other.  It's just a matter of which way of creating and
  71. ;;; managing them is most appropriate to your application.
  72. ;;;
  73. ;;; Implementation details:
  74. ;;; =======================
  75. ;;;
  76. ;;; This package uses extents with a non-nil 'text-prop property.  It assumes
  77. ;;; free reign over the endpoints of any extent with that property.  It will
  78. ;;; not alter any extent which does not have that property.
  79. ;;;
  80. ;;; Right now, the text-property functions create one extent for each distinct
  81. ;;; property; that is, if a range of text has two text-properties on it, there
  82. ;;; will be two extents.  As the set of text-properties is going to be small,
  83. ;;; this is probably not a big deal.  It would be possible to share extents.
  84. ;;;
  85. ;;; One tricky bit is that undo/kill/yank must be made to not fragment things:
  86. ;;; these extents must not be allowed to overlap.  We accomplish this by using
  87. ;;; a custom `paste-function' property on the extents.
  88. ;;;
  89. ;;; shell-font.el and font-lock.el could put-text-property to attach fonts to
  90. ;;; the buffer.  However, what these packages are interested in is the
  91. ;;; efficient extent partitioning behavior which this code exhibits, not the
  92. ;;; duplicability aspect of it.  In fact, either of these packages could be be
  93. ;;; implemented by creating a one-character non-expandable extent for each
  94. ;;; character in the buffer, except that that would be extremely wasteful of
  95. ;;; memory.  (Redisplay performance would be fine, however.)
  96. ;;;
  97. ;;; If these packages were to use put-text-property to make the extents, then
  98. ;;; when one copied text from a shell buffer or a font-locked source buffer
  99. ;;; and pasted it somewhere else (a sendmail buffer, or a buffer not in
  100. ;;; font-lock mode) then the fonts would follow, and there's no easy way to
  101. ;;; get rid of them (other than pounding out a call to put-text-property by
  102. ;;; hand.)  This is annoying.  Maybe it wouldn't be so annoying if there was a
  103. ;;; more general set of commands for handling styles of text (in fact, if
  104. ;;; there were such a thing, copying the fonts would probably be exactly what
  105. ;;; one wanted) but we aren't there yet.  So these packages use the interface
  106. ;;; of `put-nonduplicable-text-property' which is the same, except that it
  107. ;;; doesn't make duplicable extents.
  108. ;;;
  109. ;;; `put-text-property' and `put-nonduplicable-text-property' don't get along:
  110. ;;; they will interfere with each other, reusing each others' extents without
  111. ;;; checking that the "duplicableness" is correct.  This is a bug, but it's
  112. ;;; one that I don't care enough to fix this right now.
  113.  
  114.  
  115. ;;; Code:
  116.  
  117.  
  118. ;; The following functions were ported to C for speed; the overhead of doing
  119. ;; this many full lisp function calls was not small.
  120.  
  121. ;;;;###autoload
  122. ;(defun put-text-property (start end prop value &optional buffer)
  123. ;  "Adds the given property/value to all characters in the specified region.
  124. ;The property is conceptually attached to the characters rather than the
  125. ;region.  The properties are copied when the characters are copied/pasted."
  126. ;  (put-text-property-1 start end prop value buffer t)
  127. ;  prop)
  128. ;
  129. ;;;;###autoload
  130. ;(defun put-nonduplicable-text-property (start end prop value &optional buffer)
  131. ;  "Adds the given property/value to all characters in the specified region.
  132. ;The property is conceptually attached to the characters rather than the
  133. ;region, however the properties will not be copied the characters are copied."
  134. ;  (put-text-property-1 start end prop value buffer nil)
  135. ;  prop)
  136. ;
  137. ;(defun put-text-property-1 (start end prop value buffer duplicable)
  138. ;  ;; returns whether any property of a character was changed
  139. ;  (if (= start end)
  140. ;      nil
  141. ;    (save-excursion
  142. ;      (and buffer (set-buffer buffer))
  143. ;      (let ((the-extent nil)
  144. ;        (changed nil))
  145. ;    ;; prop, value, the-extent, start, end, and changed are of dynamic
  146. ;    ;; scope.  changed and the-extent are assigned.
  147. ;    (map-extents (function put-text-property-mapper) nil
  148. ;             (max 1 (1- start))
  149. ;             (min (buffer-size) (1+ end)))
  150. ;
  151. ;    ;; If we made it through the loop without reusing an extent
  152. ;    ;; (and we want there to be one) make it now.
  153. ;    (cond ((and value (not the-extent))
  154. ;           (setq the-extent (make-extent start end))
  155. ;           (set-extent-property the-extent 'text-prop prop)
  156. ;           (set-extent-property the-extent prop value)
  157. ;           (setq changed t)
  158. ;           (cond (duplicable
  159. ;              (set-extent-property the-extent 'duplicable t)
  160. ;              (set-extent-property the-extent 'paste-function
  161. ;                       'text-prop-extent-paste-function)))
  162. ;           ))
  163. ;    changed))))
  164. ;
  165. ;(defun put-text-property-mapper (e ignore)
  166. ;  ;; prop, value, the-extent, start, end, and changed are of dynamic scope.
  167. ;  ;; changed and the-extent are assigned.
  168. ;  (let ((e-start (extent-start-position e))
  169. ;    (e-end (extent-end-position e))
  170. ;    (e-val (extent-property e prop)))
  171. ;    (cond ((not (eq (extent-property e 'text-prop) prop))
  172. ;           ;; It's not for this property; do nothing.
  173. ;           nil)
  174. ;
  175. ;      ((and value
  176. ;        (not the-extent)
  177. ;        (eq value e-val))
  178. ;       ;; we want there to be an extent here at the end, and we haven't
  179. ;       ;; picked one yet, so use this one.  Extend it as necessary.
  180. ;       ;; We only reuse an extent which has an EQ value for the prop in
  181. ;       ;; question to avoid side-effecting the kill ring (that is, we
  182. ;       ;; never change the property on an extent after it has been
  183. ;       ;; created.)
  184. ;       (cond
  185. ;        ((or (/= e-start start) (/= e-end end))
  186. ;         (set-extent-endpoints e (min e-start start) (max e-end end))
  187. ;         (setq changed t)))
  188. ;       (setq the-extent e))
  189. ;
  190. ;      ;; Even if we're adding a prop, at this point, we want all other
  191. ;      ;; extents of this prop to go away (as now they overlap.)
  192. ;      ;; So the theory here is that, when we are adding a prop to a
  193. ;      ;; region that has multiple (disjoint) occurences of that prop
  194. ;      ;; in it already, we pick one of those and extend it, and remove
  195. ;      ;; the others.
  196. ;
  197. ;      ((eq e the-extent)
  198. ;       ;; just in case map-extents hits it again (does that happen?)
  199. ;       nil)
  200. ;
  201. ;      ((and (>= e-start start)
  202. ;        (<= e-end end))
  203. ;       ;; extent is contained in region; remove it.  Don't destroy or
  204. ;       ;; modify it, because we don't want to change the attributes
  205. ;       ;; pointed to by the duplicates in the kill ring.
  206. ;       (setq changed t)
  207. ;       (detach-extent e))
  208. ;
  209. ;      ((and the-extent
  210. ;        (eq value e-val)
  211. ;        (<= e-start end)
  212. ;        (>= e-end start))
  213. ;       ;; this extent overlaps, and has the same prop/value as the
  214. ;       ;; extent we've decided to reuse, so we can remove this existing
  215. ;       ;; extent as well (the whole thing, even the part outside of the
  216. ;       ;; region) and extend the-extent to cover it, resulting in the
  217. ;       ;; minimum number of extents in the buffer.
  218. ;       (cond
  219. ;        ((and (/= (extent-start-position the-extent) e-start)
  220. ;          (/= (extent-end-position the-extent) e-end))
  221. ;         (set-extent-endpoints the-extent
  222. ;                   (min (extent-start-position the-extent)
  223. ;                    e-start)
  224. ;                   (max (extent-end-position the-extent)
  225. ;                    e-end))
  226. ;         (setq changed t)))
  227. ;       (detach-extent e))
  228. ;
  229. ;      ((<= (extent-end-position e) end)
  230. ;       ;; extent begins before start but ends before end,
  231. ;       ;; so we can just decrease its end position.
  232. ;       (if (and (= (extent-start-position e) e-start)
  233. ;            (= (extent-end-position e) start))
  234. ;           nil
  235. ;         (set-extent-endpoints e e-start start)
  236. ;         (setq changed t)))
  237. ;
  238. ;      ((>= (extent-start-position e) start)
  239. ;       ;; extent ends after end but begins after start,
  240. ;       ;; so we can just increase its start position.
  241. ;       (if (and (= (extent-start-position e) end)
  242. ;            (= (extent-start-position e) e-end))
  243. ;           nil
  244. ;         (set-extent-endpoints e end e-end)
  245. ;         (setq changed t)))
  246. ;
  247. ;      (t
  248. ;       ;; Otherwise, the extent straddles the region.
  249. ;       ;; We need to split it.
  250. ;       (set-extent-endpoints e e-start start)
  251. ;       (setq e (copy-extent e))
  252. ;       (set-extent-endpoints e end e-end)
  253. ;       (setq changed t))))
  254. ;  ;; return nil to continue mapping over region.
  255. ;  nil)
  256. ;
  257. ;
  258. ;(defun text-prop-extent-paste-function (extent from to)
  259. ;  ;; Whenever a text-prop extent is pasted into a buffer (via `yank' or
  260. ;  ;; `insert' or whatever) we attach the properties to the buffer by calling
  261. ;  ;; `put-text-property' instead of by simply alowing the extent to be copied
  262. ;  ;; or re-attached.  Then we return nil, telling the C code not to attach
  263. ;  ;; it again. By handing the insertion hackery in this way, we make kill/yank
  264. ;  ;; behave consistently iwth put-text-property and not fragment the extents
  265. ;  ;; (since text-prop extents must partition, not overlap.)
  266. ;  (let* ((prop (or (extent-property extent 'text-prop)
  267. ;           (error "internal error: no text-prop on %S" extent)))
  268. ;     (val (or (extent-property extent prop)
  269. ;          (error "internal error: no text-prop %S on %S"
  270. ;             prop extent))))
  271. ;    (put-text-property from to prop val)
  272. ;    nil))
  273. ;             
  274. ;;;;###autoload
  275. ;(defun add-text-properties (start end props &optional buffer)
  276. ;  "Add properties to the characters from START to END.
  277. ;The third argument PROPS is a property list specifying the property values
  278. ;to add.  The optional fourth argument, OBJECT, is the buffer containing the
  279. ;text.  Returns t if any property was changed, nil otherwise."
  280. ;  (let ((changed nil))
  281. ;    (while props
  282. ;      (setq changed
  283. ;        (or (put-text-property-1 start end (car props) (car (cdr props))
  284. ;                     buffer t)
  285. ;        changed))
  286. ;      (setq props (cdr (cdr props))))
  287. ;    changed))
  288. ;
  289. ;;;;###autoload
  290. ;(defun remove-text-properties (start end props &optional buffer)
  291. ;  "Remove the given properties from all characters in the specified region.
  292. ;PROPS should be a plist, but the values in that plist are ignored (treated
  293. ;as nil.)  Returns t if any property was changed, nil otherwise."
  294. ;  (let ((changed nil))
  295. ;    (while props
  296. ;      (setq changed
  297. ;        (or (put-text-property-1 start end (car props) nil buffer t)
  298. ;        changed))
  299. ;      (setq props (cdr (cdr props))))
  300. ;    changed))
  301. ;
  302. ;;;;###autoload
  303. (defun set-text-properties (start end props &optional buffer)
  304.   "You should NEVER use this function.  It is ideologically blasphemous.
  305. It is provided only to ease porting of broken FSF Emacs programs."
  306.   (map-extents #'(lambda (extent ignored)
  307.            (remove-text-properties start end
  308.                        (list (extent-property extent
  309.                                   'text-prop)
  310.                          nil)
  311.                        buffer))
  312.            buffer start end nil nil 'text-prop)
  313.   (add-text-properties start end props buffer))
  314.  
  315.  
  316. ;;; The following functions can probably stay in lisp, since they're so simple.
  317.  
  318. ;;;###autoload
  319. (defun get-text-property (pos prop &optional buffer)
  320.   "Returns the value of the PROP property at the given position."
  321.   (let ((e (extent-at pos buffer prop)))
  322.     (if e
  323.     (extent-property e prop)
  324.       nil)))
  325.  
  326. (defun extent-properties-at-1 (position buffer text-props-only)
  327.   (let ((extent nil)
  328.     (props nil)
  329.     new-props)
  330.     (while (setq extent (extent-at position buffer
  331.                    (if text-props-only 'text-prop nil)
  332.                    extent))
  333.       (if text-props-only
  334.       ;; Only return the one prop which the `text-prop' property points at.
  335.       (let ((prop (extent-property extent 'text-prop)))
  336.         (setq new-props (list prop (extent-property extent prop))))
  337.     ;; Return all the properties...
  338.     (setq new-props (extent-properties extent))
  339.     ;; ...but!  Don't return the `begin-glyph' or `end-glyph' properties
  340.     ;; unless the position is exactly at the appropriate endpoint.  Yeah,
  341.     ;; this is kind of a kludge.
  342.     ;; #### Bug, this doesn't work for end-glyphs (on end-open extents)
  343.     ;; because we've already passed the extent with the glyph by the time
  344.     ;; it's appropriate to return the glyph.  We could return the end
  345.     ;; glyph one character early I guess...  But then next-property-change
  346.     ;; would have to stop one character early as well.  It could back up
  347.     ;; when it hit an end-glyph...
  348.     ;; #### Another bug, if there are multiple glyphs at the same position,
  349.     ;; we only see the first one.
  350.     (cond ((or (extent-begin-glyph extent) (extent-end-glyph extent))
  351.            (if (/= position (if (extent-property extent 'begin-glyph)
  352.                     (extent-start-position extent)
  353.                   (extent-end-position extent)))
  354.            (let ((rest new-props)
  355.              prev)
  356.              (while rest
  357.                (cond ((or (eq (car rest) 'begin-glyph)
  358.                   (eq (car rest) 'end-glyph))
  359.                   (if prev
  360.                   (setcdr prev (cdr (cdr rest)))
  361.                 (setq new-props (cdr (cdr new-props))))
  362.                   (setq rest nil)))
  363.                (setq prev rest
  364.                  rest (cdr rest))))))))
  365.       (cond ((null props)
  366.          (setq props new-props))
  367.         (t
  368.          (while new-props
  369.            (or (getf props (car new-props))
  370.            (setq props (cons (car new-props)
  371.                      (cons (car (cdr new-props))
  372.                        props))))
  373.            (setq new-props (cdr (cdr new-props)))))))
  374.     props))
  375.  
  376. ;;;###autoload
  377. (defun extent-properties-at (position &optional buffer)
  378.   "Returns the properties of the character at the given position,
  379. by merging the properties of overlapping extents.  The returned value
  380. is a property list, some of which may be shared with other structures.
  381. You must not modify it.
  382.  
  383. This returns all properties on all extents."
  384.   (extent-properties-at-1 position buffer nil))
  385.  
  386. ;;;###autoload
  387. (defun text-properties-at (position &optional buffer)
  388.   "Returns the properties of the character at the given position,
  389. by merging the properties of overlapping extents.  The returned value
  390. is a property list, some of which may be shared with other structures.
  391. You must not modify it.
  392.  
  393. This returns only those properties added with `put-text-property'.
  394. See also `extent-properties-at'."
  395.   (extent-properties-at-1 position buffer t))
  396.  
  397. ;;;###autoload
  398. (defun text-property-any (start end prop value &optional buffer)
  399.   "Check text from START to END to see if PROP is ever `eq' to VALUE.
  400. If so, return the position of the first character whose PROP is `eq'
  401. to VALUE.  Otherwise return nil.
  402. The optional fifth argument, OBJECT, is the buffer containing the text."
  403.   (while (and start (< start end)
  404.           (not (eq value (get-text-property start prop buffer))))
  405.     (setq start (next-single-property-change start prop buffer end)))
  406.   ;; we have to insert a special check for end due to the illogical
  407.   ;; definition of next-single-property-change (blame FSF for this).
  408.   (if (eq start end) nil start))
  409.  
  410. ;;;###autoload
  411. (defun text-property-not-all (start end prop value &optional buffer)
  412.   "Check text from START to END to see if PROP is ever not `eq' to VALUE.
  413. If so, return the position of the first character whose PROP is not
  414. `eq' to VALUE.  Otherwise, return nil.
  415. The optional fifth argument, OBJECT, is the buffer containing the text."
  416.   (if (not (eq value (get-text-property start prop buffer)))
  417.       start
  418.     (let ((retval (next-single-property-change start prop buffer end)))
  419.       ;; we have to insert a special check for end due to the illogical
  420.       ;; definition of previous-single-property-change (blame FSF for this).
  421.       (if (eq retval end) nil retval))))
  422.  
  423. ;;;###autoload
  424. (defun next-property-change (pos &optional buffer limit)
  425.   "Return the position of next property change.
  426. Scans forward from POS in BUFFER (defaults to the current buffer) until
  427.  it finds a change in some text property, then returns the position of
  428.  the change.
  429. Returns nil if the properties remain unchanged all the way to the end.
  430. If the value is non-nil, it is a position greater than POS, never equal.
  431. If the optional third argument LIMIT is non-nil, don't search
  432.  past position LIMIT; return LIMIT if nothing is found before LIMIT.
  433. If two or more extents with conflicting non-nil values for a property overlap
  434.  a particular character, it is undefined which value is considered to be
  435.  the value of the property. (Note that this situation will not happen if
  436.  you always use the text-property primitives.)"
  437.   (let ((limit-was-nil (null limit)))
  438.     (or limit (setq limit (point-max buffer)))
  439.     (let ((value (extent-properties-at pos buffer)))
  440.       (while
  441.       (and (< (setq pos (next-extent-change pos buffer)) limit)
  442.            (plists-eq value (extent-properties-at pos buffer)))))
  443.     (if (< pos limit) pos
  444.       (if limit-was-nil nil
  445.     limit))))
  446.  
  447. ;;;###autoload
  448. (defun previous-property-change (pos &optional buffer limit)
  449.   "Return the position of previous property change.
  450. Scans backward from POS in BUFFER (defaults to the current buffer) until
  451.  it finds a change in some text property, then returns the position of
  452.  the change.
  453. Returns nil if the properties remain unchanged all the way to the beginning.
  454. If the value is non-nil, it is a position less than POS, never equal.
  455. If the optional third argument LIMIT is non-nil, don't search back
  456.  past position LIMIT; return LIMIT if nothing is found until LIMIT.
  457. If two or more extents with conflicting non-nil values for a property overlap
  458.  a particular character, it is undefined which value is considered to be
  459.  the value of the property. (Note that this situation will not happen if
  460.  you always use the text-property primitives.)"
  461.   (let ((limit-was-nil (null limit)))
  462.     (or limit (setq limit (point-min buffer)))
  463.     (let ((value (extent-properties-at (1- pos) buffer)))
  464.       (while
  465.       (and (> (setq pos (previous-extent-change pos buffer)) limit)
  466.            (plists-eq value (extent-properties-at (1- pos) buffer)))))
  467.     (if (> pos limit) pos
  468.       (if limit-was-nil nil
  469.     limit))))
  470.  
  471. ;(defun detach-all-extents (&optional buffer)
  472. ;  (map-extents #'(lambda (x i) (detach-extent x) nil)
  473. ;           buffer))
  474.  
  475. ;(defun buffer-extents (&optional buffer)
  476. ;  (let* ((e (next-extent buffer))
  477. ;     (rest (list e)))
  478. ;    (while (setq e (next-extent e)) (setq rest (cons e rest)))
  479. ;    (nreverse rest)))
  480.  
  481.  
  482. (provide 'text-props)
  483.  
  484. ;;; text-props.el ends here
  485.